home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / trigo.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  16.1 KB  |  385 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module trigo)
  13.  
  14. (LOAD-MACSYMA-MACROS MRGMAC)
  15.  
  16. (DECLARE-TOP (GENPREFIX TRI)
  17.      (SPECIAL VARLIST ERRORSW)
  18.      (FLONUM (TAN) (COT) (SEC) (CSC)
  19.          (ATAN2) (ATAN1) (ACOT)
  20.          (SINH) (COSH) (TANH) (COTH) (CSCH) (SECH)
  21.          (ASINH) (ACSCH)
  22.          (T//$ FLONUM FLONUM NOTYPE))
  23.      (*EXPR $BFLOAT TEVAL SIGNUM1 ZEROP1 ISLINEAR
  24.         TIMESK ADDK MAXIMA-INTEGERP EVOD LOGARC MEVENP HALFANGLE COEFF))
  25.  
  26. (declare-top (SPLITFILE hyper))
  27.  
  28. (DEFMFUN SIMP-%SINH (FORM Y Z) 
  29.   (ONEARGCHECK FORM)
  30.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  31.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (SINH Y))
  32.     (($BFLOATP Y) ($BFLOAT FORM))
  33.     ((AND $%PIARGS (IF (ZEROP1 Y) 0)))
  34.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%SIN (COEFF Y '$%I 1))))
  35.     ((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ASINH (CAAR Y)) (CADR Y))))
  36.     ((AND $TRIGEXPAND (TRIGEXPAND '%SINH Y)))
  37.     ($EXPONENTIALIZE (EXPONENTIALIZE '%SINH Y))
  38.     ((AND $HALFANGLES (HALFANGLE '%SINH Y)))
  39.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%SINH (NEG Y))))
  40.     (T (EQTEST (LIST '(%SINH) Y) FORM))))
  41.  
  42. (DEFMFUN SIMP-%COSH (FORM Y Z) 
  43.   (ONEARGCHECK FORM)
  44.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  45.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (COSH Y))
  46.     (($BFLOATP Y) ($BFLOAT FORM))
  47.     ((AND $%PIARGS (IF (ZEROP1 Y) 1)))
  48.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%COS (COEFF Y '$%I 1)))
  49.     ((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACOSH (CAAR Y)) (CADR Y))))
  50.     ((AND $TRIGEXPAND (TRIGEXPAND '%COSH Y)))
  51.     ($EXPONENTIALIZE (EXPONENTIALIZE '%COSH Y))
  52.     ((AND $HALFANGLES (HALFANGLE '%COSH Y)))
  53.     ((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%COSH (NEG Y)))
  54.     (T (EQTEST (LIST '(%COSH) Y) FORM))))
  55.  
  56. (DEFMFUN SIMP-%TANH (FORM Y Z)
  57.   (ONEARGCHECK FORM)
  58.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  59.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (TANH Y))
  60.     (($BFLOATP Y) ($BFLOAT FORM))
  61.     ((AND $%PIARGS (IF (ZEROP1 Y) 0)))
  62.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%TAN (COEFF Y '$%I 1))))
  63.     ((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ATANH (SETQ Z (CAAR Y))) (CADR Y))))
  64.     ((AND $TRIGEXPAND (TRIGEXPAND '%TANH Y)))
  65.     ($EXPONENTIALIZE (EXPONENTIALIZE '%TANH Y))
  66.     ((AND $HALFANGLES (HALFANGLE '%TANH Y)))
  67.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%TANH (NEG Y))))
  68.     (T (EQTEST (LIST '(%TANH) Y) FORM))))
  69.  
  70. (DEFMFUN SIMP-%COTH (FORM Y Z)
  71.   (ONEARGCHECK FORM)
  72.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  73.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (COTH Y))
  74.     (($BFLOATP Y) ($BFLOAT FORM))
  75.     ((AND $%PIARGS (IF (ZEROP1 Y) (DBZ-ERR1 'COTH))))
  76.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%COT (COEFF Y '$%I 1))))
  77.     ((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACOTH (CAAR Y)) (CADR Y))))
  78.     ((AND $TRIGEXPAND (TRIGEXPAND '%COTH Y)))
  79.     ($EXPONENTIALIZE (EXPONENTIALIZE '%COTH Y))
  80.     ((AND $HALFANGLES (HALFANGLE '%COTH Y)))
  81.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%COTH (NEG Y))))
  82.     (T (EQTEST (LIST '(%COTH) Y) FORM))))
  83.  
  84. (DEFMFUN SIMP-%CSCH (FORM Y Z)
  85.   (ONEARGCHECK FORM)
  86.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  87.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (CSCH Y))
  88.     (($BFLOATP Y) ($BFLOAT FORM))
  89.     ((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'CSCH)))))
  90.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%CSC (COEFF Y '$%I 1))))
  91.     ((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACSCH (CAAR Y)) (CADR Y))))
  92.     ((AND $TRIGEXPAND (TRIGEXPAND '%CSCH Y)))
  93.     ($EXPONENTIALIZE (EXPONENTIALIZE '%CSCH Y))
  94.     ((AND $HALFANGLES (HALFANGLE '%CSCH Y)))
  95.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%CSCH (NEG Y))))
  96.     (T (EQTEST (LIST '(%CSCH) Y) FORM))))
  97.  
  98. (DEFMFUN SIMP-%SECH (FORM Y Z)
  99.   (ONEARGCHECK FORM)
  100.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  101.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (SECH Y))
  102.     (($BFLOATP Y) ($BFLOAT FORM))
  103.     ((AND $%PIARGS (ZEROP1 Y)) 1)
  104.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%SEC (COEFF Y '$%I 1)))
  105.     ((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ASECH (CAAR Y)) (CADR Y))))
  106.     ((AND $TRIGEXPAND (TRIGEXPAND '%SECH Y)))
  107.     ($EXPONENTIALIZE (EXPONENTIALIZE '%SECH Y))
  108.     ((AND $HALFANGLES (HALFANGLE '%SECH Y)))
  109.     ((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%SECH (NEG Y)))
  110.     (T (EQTEST (LIST '(%SECH) Y) FORM))))
  111.  
  112. (declare-top (SPLITFILE ATRIG))
  113.  
  114. (DEFMFUN SIMP-%ASIN (FORM Y Z) 
  115.   (ONEARGCHECK FORM)
  116.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  117.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (ASIN Y))
  118.     (($BFLOATP Y) ($BFLOAT FORM))
  119.     ((AND $%PIARGS 
  120.           (COND ((ZEROP1 Y) 0) ((EQUAL 1 Y) %PI//2) ((EQUAL -1 Y) (NEG %PI//2))
  121.             ((ALIKE1 Y 1//2) (MUL '((RAT SIMP) 1 6) '$%PI)))))
  122.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ASINH (COEFF Y '$%I 1))))
  123.     ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) (IF (EQ '%SIN (CAAR Y)) (CADR Y))))
  124.     ($LOGARC (LOGARC '%ASIN Y))
  125.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ASIN (NEG Y))))
  126.     (T (EQTEST (LIST '(%ASIN) Y) FORM))))
  127.  
  128. (DEFMFUN SIMP-%ACOS (FORM Y Z)
  129.   (ONEARGCHECK FORM)
  130.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  131.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (ACOS Y))
  132.     (($BFLOATP Y) ($BFLOAT FORM))
  133.     ((AND $%PIARGS 
  134.           (COND ((ZEROP1 Y) %PI//2) ((EQUAL 1 Y) 0) ((EQUAL -1 Y) '$%PI)
  135.             ((ALIKE1 Y 1//2) (MUL '((RAT SIMP) 1 3) '$%PI)))))
  136.     ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
  137.           (IF (EQ '%COS (CAAR Y)) (CADR Y))))
  138.     ($LOGARC (LOGARC '%ACOS Y))
  139.     ((AND $TRIGSIGN (MMINUSP* Y)) (SUB '$%PI (CONS-EXP '%ACOS (NEG Y))))
  140.     (T (EQTEST (LIST '(%ACOS) Y) FORM))))
  141.  
  142. (DEFMFUN SIMP-%ACOT (FORM Y Z)
  143.   (ONEARGCHECK FORM)
  144.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  145.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (ACOT Y))
  146.     (($BFLOATP Y) ($BFLOAT FORM))
  147.     ((AND $%PIARGS
  148.           (COND ((ZEROP1 Y) %PI//2) ((EQUAL 1 Y) %PI//4) ((EQUAL -1 Y) (NEG %PI//4)))))
  149.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACOTH (COEFF Y '$%I 1))))
  150.     ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
  151.           (IF (EQ '%COT (CAAR Y)) (CADR Y))))
  152.     ($LOGARC (LOGARC '%ACOT Y))
  153.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACOT (NEG Y))))
  154.     (T (EQTEST (LIST '(%ACOT) Y) FORM))))
  155.  
  156. (DEFMFUN SIMP-%ACSC (FORM Y Z)
  157.   (ONEARGCHECK FORM)
  158.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  159.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (ACSC Y))
  160.     (($BFLOATP Y) ($BFLOAT FORM))
  161.     ((AND $%PIARGS
  162.           (COND ((EQUAL 1 Y) %PI//2) ((EQUAL -1 Y) (NEG %PI//2)))))
  163.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACSCH (COEFF Y '$%I 1))))
  164.     ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
  165.           (IF (EQ '%CSC (CAAR Y)) (CADR Y))))
  166.     ($LOGARC (LOGARC '%ACSC Y))
  167.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACSC (NEG Y))))
  168.     (T (EQTEST (LIST '(%ACSC) Y) FORM))))
  169.  
  170. (DEFMFUN SIMP-%ASEC (FORM Y Z)
  171.   (ONEARGCHECK FORM)
  172.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  173.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (ASEC Y))
  174.     (($BFLOATP Y) ($BFLOAT FORM))
  175.     ((AND $%PIARGS 
  176.           (COND ((EQUAL 1 Y) 0) ((EQUAL -1 Y) '$%PI))))
  177.     ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
  178.           (IF (EQ '%SEC (CAAR Y)) (CADR Y))))
  179.     ($LOGARC (LOGARC '%ASEC Y))
  180.     ((AND $TRIGSIGN (MMINUSP* Y)) (SUB '$%PI (CONS-EXP '%ASEC (NEG Y))))
  181.     (T (EQTEST (LIST '(%ASEC) Y) FORM))))
  182.  
  183. (declare-top (SPLITFILE AHYPER))
  184.  
  185. (DEFMFUN SIMP-%ASINH (FORM Y Z)
  186.   (ONEARGCHECK FORM)
  187.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  188.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (ASINH Y))
  189.     (($BFLOATP Y) ($BFLOAT FORM))
  190.     ((AND $%PIARGS (IF (ZEROP1 Y) Y)))
  191.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ASIN (COEFF Y '$%I 1))))
  192.     ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
  193.           (IF (EQ '%SINH (CAAR Y)) (CADR Y))))
  194.     ($LOGARC (LOGARC '%ASINH Y))
  195.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ASINH (NEG Y))))
  196.     (T (EQTEST (LIST '(%ASINH) Y) FORM))))
  197.  
  198. (DEFMFUN SIMP-%ACOSH (FORM Y Z)
  199.   (ONEARGCHECK FORM)
  200.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  201.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (ACOSH Y))
  202.     (($BFLOATP Y) ($BFLOAT FORM))
  203.     ((AND $%PIARGS (IF (EQUAL Y 1) 0)))
  204.     ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
  205.           (IF (EQ '%COSH (CAAR Y)) (CADR Y))))
  206.     ($LOGARC (LOGARC '%ACOSH Y))
  207.     (T (EQTEST (LIST '(%ACOSH) Y) FORM))))
  208.  
  209. (DEFMFUN SIMP-%ATANH (FORM Y Z)
  210.   (ONEARGCHECK FORM)
  211.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  212.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (ATANH Y))
  213.     (($BFLOATP Y) ($BFLOAT FORM))
  214.     ((AND $%PIARGS (COND ((ZEROP1 Y) 0)
  215.                  ((OR (EQUAL Y 1) (EQUAL Y -1)) (DBZ-ERR1 'ATANH)))))
  216.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ATAN (COEFF Y '$%I 1))))
  217.     ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
  218.           (IF (EQ '%TANH (CAAR Y)) (CADR Y))))
  219.     ($LOGARC (LOGARC '%ATANH Y))
  220.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ATANH (NEG Y))))
  221.     (T (EQTEST (LIST '(%ATANH) Y) FORM))))
  222.  
  223. (DEFMFUN SIMP-%ACOTH (FORM Y Z)
  224.   (ONEARGCHECK FORM)
  225.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  226.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (ACOTH Y))
  227.     (($BFLOATP Y) ($BFLOAT FORM))
  228.     ((AND $%PIARGS (IF (OR (EQUAL Y 1) (EQUAL Y -1)) (DBZ-ERR1 'ACOTH))))
  229.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACOT (COEFF Y '$%I 1))))
  230.     ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
  231.           (IF (EQ '%COTH (CAAR Y)) (CADR Y))))
  232.     ($LOGARC (LOGARC '%ACOTH Y))
  233.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACOTH (NEG Y))))
  234.     (T (EQTEST (LIST '(%ACOTH) Y) FORM))))
  235.  
  236. (DEFMFUN SIMP-%ACSCH (FORM Y Z)
  237.   (ONEARGCHECK FORM)
  238.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  239.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (ACSCH Y))
  240.     (($BFLOATP Y) ($BFLOAT FORM))
  241.     ((AND $%PIARGS (IF (ZEROP1 Y) (DBZ-ERR1 'ACSCH))))
  242.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACSC (COEFF Y '$%I 1))))
  243.     ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
  244.           (IF (EQ '%CSCH (CAAR Y)) (CADR Y))))
  245.     ($LOGARC (LOGARC '%ACSCH Y))
  246.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACSCH (NEG Y))))
  247.     (T (EQTEST (LIST '(%ACSCH) Y) FORM))))
  248.  
  249. (DEFMFUN SIMP-%ASECH (FORM Y Z)
  250.   (ONEARGCHECK FORM)
  251.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  252.   (COND ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y))) (ASECH Y))
  253.     (($BFLOATP Y) ($BFLOAT FORM))
  254.     ((AND $%PIARGS (COND ((EQUAL Y 1) 0)
  255.                  ((ZEROP1 Y) (DBZ-ERR1 'ASECH)))))
  256.     ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
  257.           (IF (EQ '%SECH (CAAR Y)) (CADR Y))))
  258.     ($LOGARC (LOGARC '%ASECH Y))
  259.     ((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%ASECH (NEG Y)))
  260.     (T (EQTEST (LIST '(%ASECH) Y) FORM))))
  261.  
  262. (declare-top (SPLITFILE TRIGEX) (SPECIAL $TRIGEXPANDPLUS $TRIGEXPANDTIMES))
  263.  
  264. (DEFMFUN $TRIGEXPAND (E)
  265.   (COND ((ATOM E) E)
  266.     ((SPECREPP E) ($TRIGEXPAND (SPECDISREP E)))
  267.     ((TRIGEXPAND (CAAR E) (CADR E)))
  268.     (T (RECUR-APPLY #'$TRIGEXPAND E))))
  269.  
  270. (DEFMFUN TRIGEXPAND (OP ARG)
  271.   (COND ((ATOM ARG) NIL)
  272.     ((AND $TRIGEXPANDPLUS (EQ 'MPLUS (CAAR ARG)))
  273.      (COND ((EQ '%SIN OP) (SIN\COS-PLUS (CDR ARG) 1 '%SIN '%COS -1))
  274.            ((EQ '%COS OP) (SIN\COS-PLUS (CDR ARG) 0 '%SIN '%COS -1))
  275.            ((EQ '%TAN OP) (TAN-PLUS (CDR ARG) '%TAN -1))
  276.            ((EQ '%COT OP) (COT-PLUS (CDR ARG) '%COT -1))
  277.            ((EQ '%CSC OP) (CSC\SEC-PLUS (CDR ARG) 1 '%CSC '%SEC -1))
  278.            ((EQ '%SEC OP) (CSC\SEC-PLUS (CDR ARG) 0 '%CSC '%SEC -1))
  279.            ((EQ '%SINH OP) (SIN\COS-PLUS (CDR ARG) 1 '%SINH '%COSH 1))
  280.            ((EQ '%COSH OP) (SIN\COS-PLUS (CDR ARG) 0 '%SINH '%COSH 1))
  281.            ((EQ '%TANH OP) (TAN-PLUS (CDR ARG) '%TANH 1))
  282.            ((EQ '%COTH OP) (COT-PLUS (CDR ARG) '%COTH 1))
  283.            ((EQ '%CSCH OP) (CSC\SEC-PLUS (CDR ARG) 1 '%CSCH '%SECH 1))
  284.            ((EQ '%SECH OP) (CSC\SEC-PLUS (CDR ARG) 0 '%CSCH '%SECH 1))))
  285.     ((AND $TRIGEXPANDTIMES (EQ 'MTIMES (CAAR ARG)) (EQ (ml-typep (CADR ARG)) 'fixnum))
  286.      (COND ((EQ '%SIN OP) (SIN\COS-TIMES (CDDR ARG) 1 (CADR ARG) '%SIN '%COS -1))
  287.            ((EQ '%COS OP) (SIN\COS-TIMES (CDDR ARG) 0 (CADR ARG) '%SIN '%COS -1))
  288.            ((EQ '%TAN OP) (TAN-TIMES (CDDR ARG) (CADR ARG) '%TAN -1))
  289.            ((EQ '%COT OP) (COT-TIMES (CDDR ARG) (CADR ARG) '%COT -1))
  290.            ((EQ '%CSC OP) (CSC\SEC-TIMES (CDDR ARG) 1 (CADR ARG) '%CSC '%SEC -1))
  291.            ((EQ '%SEC OP) (CSC\SEC-TIMES (CDDR ARG) 0 (CADR ARG) '%CSC '%SEC -1))
  292.            ((EQ '%SINH OP) (SIN\COS-TIMES (CDDR ARG) 1 (CADR ARG) '%SINH '%COSH 1))
  293.            ((EQ '%COSH OP) (SIN\COS-TIMES (CDDR ARG) 0 (CADR ARG) '%SINH '%COSH 1))
  294.            ((EQ '%TANH OP) (TAN-TIMES (CDDR ARG) (CADR ARG) '%TANH 1))
  295.            ((EQ '%COTH OP) (COT-TIMES (CDDR ARG) (CADR ARG) '%COTH 1))
  296.            ((EQ '%CSCH OP) (CSC\SEC-TIMES (CDDR ARG) 1 (CADR ARG) '%CSCH '%SECH 1))
  297.            ((EQ '%SECH OP) (CSC\SEC-TIMES (CDDR ARG) 0 (CADR ARG) '%CSCH '%SECH 1))))))
  298.  
  299.  
  300. (DEFUN SIN\COS-PLUS (L N F1 F2 FLAG)
  301.   (DO ((I N (f+ 2 I)) (LEN (LENGTH L)) (SIGN 1 (f* FLAG SIGN)) (RESULT))
  302.       ((> I LEN) (SIMPLIFY (CONS '(MPLUS) RESULT)))
  303.       (SETQ RESULT (MPC (COND ((MINUSP SIGN) '(-1 (MTIMES))) (T '((MTIMES)))) L RESULT F1 F2 LEN I))))
  304.  
  305. (DEFUN TAN-PLUS (L F FLAG) 
  306.   (DO ((I 1 (f+ 2 I)) (SIGN 1 (f* FLAG SIGN)) (LEN (LENGTH L)) (NUM) (DEN (LIST 1)))
  307.    ((> I LEN) (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
  308.    (SETQ NUM (MPC1 (LIST SIGN '(MTIMES)) L NUM F LEN I)
  309.      DEN (COND ((= LEN I) DEN)
  310.            (T (MPC1 (LIST (f* FLAG SIGN) '(MTIMES)) L DEN F LEN (f1+ I)))))))
  311.  
  312. (DEFUN COT-PLUS (L F FLAG)
  313.   (DO ((I (LENGTH L) (f- I 2)) (LEN (LENGTH L)) (SIGN 1 (f* FLAG SIGN)) (NUM) (DEN))
  314.    ((< I 0) (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
  315.    (SETQ NUM (MPC1 (LIST SIGN '(MTIMES)) L NUM F LEN I)
  316.      DEN (COND ((= 0 I) DEN)
  317.            (T (MPC1 (LIST SIGN '(MTIMES)) L DEN F LEN (f1- I)))))))
  318.  
  319. (DEFUN CSC\SEC-PLUS (L N F1 F2 FLAG)
  320.   (DIV* (DO ((L L (CDR L)) (RESULT)) ((NULL L) (CONS '(MTIMES) RESULT))
  321.            (SETQ RESULT (CONS (CONS-EXP F1 (CAR L)) (CONS (CONS-EXP F2 (CAR L)) RESULT))))
  322.            (SIN\COS-PLUS L N F1 F2 FLAG)))
  323.  
  324. (DEFUN SIN\COS-TIMES (L M N F1 F2 FLAG)
  325. ;; Assume m,n < 2^17, but Binom may become big
  326. ;; Flag is 1 or -1
  327.   (SETQ F1 (CONS-EXP F1 (CONS '(MTIMES) L)) F2 (CONS-EXP F2 (CONS '(MTIMES) L)))
  328.   (DO ((I M (f+ 2 I)) (END (ABS N)) (RESULT)
  329.        (BINOM (COND ((= 0 M) 1) (T (ABS N))) (quotient (times (f* FLAG (f- END I 1) (f- END I)) BINOM) (f* (f+ 2 I) (f1+ I)))))
  330.       ((> I END) (SETQ RESULT (SIMPLIFY (CONS '(MPLUS) RESULT)))
  331.          (COND ((AND (= 1 M) (MINUSP N)) (NEG RESULT)) (T RESULT)))
  332.       (SETQ RESULT (CONS (MUL BINOM (POWER F1 I) (POWER F2 (f- END I))) RESULT))))
  333.  
  334. (DEFUN TAN-TIMES (L N F FLAG)
  335.   (SETQ F (CONS-EXP F (CONS '(MTIMES) L)))
  336.   (DO ((I 1 (f+ 2 I)) (END (ABS N)) (NUM) (DEN (LIST 1))
  337.        (BINOM (ABS N) (quotient (times (f- END I 1) BINOM) (f+ 2 I))))
  338.       ((> I END) (SETQ NUM (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
  339.          (COND ((MINUSP N) (NEG NUM)) (T NUM)))
  340.       (SETQ NUM (CONS (MUL BINOM (POWER F I)) NUM) 
  341.         DEN (COND ((= END I) DEN)
  342.               (T (CONS (MUL (SETQ BINOM (// (f* FLAG (f- END I) BINOM) (f1+ I)))
  343.                     (POWER F (f1+ I)))
  344.                    DEN))))))
  345.  
  346. (DEFUN COT-TIMES (L N F FLAG)
  347.   (SETQ F (CONS-EXP F (CONS '(MTIMES) L)))
  348.   (DO ((I (ABS N) (f- I 2)) (END (ABS N)) (NUM) (DEN)
  349.        (BINOM 1 (// (f* FLAG (f1- I) BINOM) (f- END I -2))))
  350.       ((< I 0) (SETQ NUM (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
  351.         (IF (MINUSP N) (NEG NUM) NUM))
  352.       (SETQ NUM (CONS (MUL BINOM (POWER F I)) NUM)
  353.         DEN (IF (= 0 I) DEN
  354.             (CONS (MUL (SETQ BINOM (// (f* I BINOM) (f- END I -1))) (POWER F (f1- I))) DEN)))))
  355.  
  356. (DEFUN CSC\SEC-TIMES (L M N F1 F2 FLAG)
  357.   (DIV* (MUL (POWER (CONS-EXP F1 (CONS '(MTIMES) L)) (ABS N))
  358.              (POWER (CONS-EXP F2 (CONS '(MTIMES) L)) (ABS N)))
  359.            (SIN\COS-TIMES L M N F1 F2 FLAG)))
  360.  
  361. (DEFUN MPC (DL UL RESULT F1 F2 DI UI) 
  362.   (COND ((= 0 UI)
  363.      (CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F2 L)) UL))
  364.            RESULT))
  365.     ((= DI UI)
  366.      (CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F1 L)) UL))
  367.            RESULT))
  368.     (T (MPC (CONS (CONS-EXP F1 (CAR UL)) DL) (CDR UL)
  369.         (MPC (CONS (CONS-EXP F2 (CAR UL)) DL)
  370.              (CDR UL) RESULT F1 F2 (f1- DI) UI) F1 F2
  371.         (f1- DI) (f1- UI)))))
  372.  
  373. (DEFUN MPC1 (DL UL RESULT F DI UI) 
  374.   (COND ((= 0 UI) (CONS (REVERSE DL) RESULT))
  375.     ((= DI UI)
  376.      (CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F L)) UL)) RESULT))
  377.     (T (MPC1 (CONS (CONS-EXP F (CAR UL)) DL) (CDR UL)
  378.          (MPC1 DL (CDR UL) RESULT F (f1- DI) UI) F
  379.          (f1- DI) (f1- UI)))))
  380.  
  381. ;; Local Modes:
  382. ;; Mode: LISP
  383. ;; Comment Col: 40
  384. ;; End:
  385.